home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / TECHNICA / AUTOCAD / 3824.ZIP / ELF110.ZIP / SELSET.LSP < prev    next >
Lisp/Scheme  |  1993-02-21  |  6KB  |  209 lines
  1. ;;; SELSET.LSP
  2. ;;; Copyright 1993 by Mountain Software
  3. ;;;
  4. ;;; This program requires ELF, the Extended List Function library
  5. ;;;
  6. ;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
  7. ;;; WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
  8. ;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
  9. ;;;
  10. ;;;*===================================================================*
  11. ;;;
  12. ;;; This is a test program to demonstrate the use of the ELF functions
  13. ;;; ss_move, ss_scale, ss_rotate which implement the AutoCAD dragger ADS
  14. ;;; function ads_draggen; ss_xform which implements ads_xform. In addition
  15. ;;; the command SSU demonstrates the use of the EFL finctions ss_union,
  16. ;;; ss_inters, and ss_diff.
  17. ;;;
  18. ;;; The drag functions don't change the selection set but only provide a
  19. ;;; means for the user to visualize a user defined entity modification
  20. ;;; function. The AutoLISP programmer can then use ss_xform and / or
  21. ;;; combinations of AutoLISP functions and AutoCAD commands to modify
  22. ;;; the selection set.
  23. ;;;
  24. ;;; For instance, a COPY_SCALE command could be made that creats a new copy
  25. ;;; of a selection set scaled and translated leaving the original intact.
  26. ;;; the ss_scale function would be called to let the user drag the selection
  27. ;;; set and then the COPY command invoked followed by ss_xform to do the
  28. ;;; scaling.
  29.  
  30. (Princ "\nLoading SelSet.Lsp...")
  31. (Load"ELF")                             ;load ELF.EXP, color and key symbols
  32.  
  33. ;*------ supporting functions -------
  34.  
  35. ;;; multiply vectors
  36.  
  37. (defun mult_vec (v1 v2)
  38.   (mapcar '* v1 v2)
  39. )
  40.  
  41. ;;; subtract vectors
  42.  
  43. (defun sub_vec (v1 v2)
  44.   (mapcar '- v1 v2)
  45. )
  46.  
  47. ;;; sum a vector
  48.  
  49. (defun sum_vec (v)
  50.   (+ (car v)(cadr v)(caddr v))
  51. )
  52.  
  53. ;;; multiply a matrix and a vector
  54.  
  55. (defun mat_x_vec(mat pt)
  56.   (mapcar '(lambda (m)
  57.              (sum_vec(mult_vec m pt))
  58.            )
  59.            mat
  60.   )
  61. )
  62.  
  63. ;;; rotate selection set in xy plane from a base point
  64.  
  65. (defun rotate(ss bp ang / ca sa nsa)
  66.   (setq ca  (cos ang)
  67.         sa  (sin ang)
  68.         nsa (* -1 sa)
  69.         mat (list(list ca nsa 0)              ; rotated matrix
  70.                  (list sa ca  0)
  71.                  (list 0  0   1))
  72.         vec (mat_x_vec mat bp)                ; translation vector
  73.         vec (sub_vec bp vec)                  ; subtract the vectors
  74.         mat (list(list ca nsa 0 (car vec))    ; rotated and translated matrix
  75.                  (list sa ca  0 (cadr vec))
  76.                  (list 0  0   1 (caddr vec)))
  77.   )
  78.   (ss_xform ss mat)
  79. )
  80.  
  81. ;;; translate a selection set
  82.  
  83. (defun move(ss pt1 pt2)
  84.   (setq v (sub_vec pt2 pt1)
  85.         mat (list (list 1 0 0 (car v))
  86.                   (list 0 1 0 (cadr v))
  87.                   (list 0 0 1 (caddr v))))
  88.   (ss_xform ss mat)
  89. )
  90.  
  91. ;;; scale a selection set relative to a base point
  92.  
  93. (defun scale(ss bp sf)
  94.   (setq mat (list (list sf 0 0 (- (car bp)   (*(car bp) sf)))
  95.                   (list 0 sf 0 (- (cadr bp)  (*(cadr bp) sf)))
  96.                   (list 0 0 sf (- (caddr bp) (*(caddr bp) sf)))))
  97.   (ss_xform ss mat)
  98. )
  99.  
  100. ;;; a work-alike scale command
  101.  
  102. (defun C:SC( / ss pt1 pt2 sf)
  103.   (setq ss (ssget))
  104.   (setq pt1 (getpoint "Base Point"))
  105.   (initget 128)
  106.   (setq pt2 (ss_scale ss pt1 "\n<Scale factor>/Reference " 5))
  107.   (setq sf (if(=(type pt2) 'STR)
  108.     (atof pt2)
  109.     (distance pt1 pt2)))
  110.   (if(scale ss pt1 sf)
  111.     (printf "\nScale Factor is %f" sf)
  112.     (princ "\nError"))
  113.   (princ)
  114. )
  115.  
  116. ;;; a work-alike move command
  117.  
  118. (defun C:MV( / ss pt1 pt2)
  119.   (setq ss (ssget))
  120.   (setq pt1 (getpoint "Base point or displacement: "))
  121.   (initget 128)
  122.   (setq pt2 (ss_move ss pt1 "\nSecond point of displacement: " 5))
  123.   (if (=(type pt2) 'STR)
  124.     (setq pt2 (read (sprintf "(%s)" pt2))))
  125.   (if(not(move ss pt1 pt2))
  126.     (princ "\nError"))
  127.   (princ)
  128. )
  129.  
  130. ;;; a work-alike rotate command
  131.  
  132. (defun C:RO( / ss pt1 pt2 ang)
  133.   (setq ss (ssget))
  134.   (setq pt1 (getpoint "Base Point: "))
  135.   (initget 128)
  136.   (setq pt2 (ss_rotate ss pt1 "\n<Rotation angle>/Reference: " 5))
  137.   (setq ang (if (=(type pt2) 'STR)
  138.     (angtof pt2)             ;convert to angle
  139.     (angle pt1 pt2)
  140.   ))
  141.   (if(rotate ss pt1 ang)
  142.     (printf "\nRotation angle is %f" (rtd ang))
  143.     (princ "\nError"))
  144.   (princ)
  145. )
  146.  
  147. ;;; a mirror command with no translation (mirrors around x or y axis)
  148. ;;;
  149. ;;; The rotation axis calculations and translation function are left
  150. ;;; as an exercise for the student (The instructor is too lazy to do it!)
  151.  
  152. (defun C:MIR()
  153.   (setq ss (ssget) ang pi
  154.         maty (list(list 1)
  155.                   (list 0 -1)
  156.                   (list 0 0 -1))     ; rotate in yz plane
  157.         matx (list(list -1)
  158.                   (list 0 1)
  159.                   (list 0 0 -1))     ; rotate in xz plane
  160.   )
  161.   (initget "X Y")
  162.   (if(= "X" (getkword "\nRotation Axis: [X/Y]"))
  163.     (ss_xform ss matx)
  164.     (ss_xform ss maty)
  165.   )
  166.   (princ)
  167. )
  168.  
  169. (defun C:SSU()
  170.   (prompt "\nSSU changes the color to red of the selection set created from logical")
  171.   (prompt "\noperators on two selection set. Pick the First selection set.")
  172.   (setq ss1 (ssget))
  173.   (prompt "Second selection set")
  174.   (setq ss2 (ssget))
  175.   (initget "Union Intersection Difference")
  176.   (setq kw (getkword "\nUnion/Intersection/Difference[Union]"))
  177.   (setq ss
  178.     (cond ((= kw "Intersection")  (ss_inters ss1 ss2))
  179.           ((= kw "Difference")    (ss_diff   ss1 ss2))
  180.           (T                      (ss_union  ss1 ss2))
  181.   ))
  182.   (if(> (sslength ss) 0)
  183.     (progn
  184.       (setvar "CMDECHO" 0)
  185.       (command ".CHPROP" ss "" "C" "1" "")
  186.     )
  187.     (prompt "\nEmpty selection set")
  188.   )
  189.   (princ)
  190. )
  191.  
  192. (DeFun C:SELSET( / mstr flst rslt fname key i)
  193.   (Setq mstr '("MV  - move a selection set"
  194.                "SC  - scale a selection set"
  195.                "RO  - rotate a selection set"
  196.                "MIR - mirror a selection set"
  197.                "SSU - logical set manipulation")
  198.         flst '(c:mv c:sc c:ro c:mir c:ssu)
  199.         rslt (Wmenu mstr))
  200.   (Cls 7)
  201.   (If(/= (Cadr rslt) Esc_Key)
  202.     (Eval(List(Nth (Car rslt) flst))))
  203.   (princ)
  204. )
  205.  
  206. (princ "\nSelSet.Lsp loaded...")
  207. (princ)
  208.  
  209.